home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: Camelot / Camelot 098 (1990-12)(Swedish User Group of Amiga)(SE)(PD)[WB].zip / Camelot 098 (1990-12)(Swedish User Group of Amiga)(SE)(PD)[WB].adf / XLisp-Stat / Functions / altlink.lsp next >
Lisp/Scheme  |  1990-10-11  |  5KB  |  127 lines
  1. ; book pp.335-339
  2.  
  3. (defproto observation-proto '(label state symbol color views))
  4. (defmeth observation-proto :label () (slot-value 'label))
  5. (defmeth observation-proto :state () (slot-value 'state))
  6. (defmeth observation-proto :symbol () (slot-value 'symbol))
  7. (defmeth observation-proto :color () (slot-value 'color))
  8. (send observation-proto :slot-value 'state 'normal)
  9. (send observation-proto :slot-value 'symbol 'disk)
  10. (defmeth observation-proto :add-view (graph key)
  11.   (setf (slot-value 'views)
  12.         (cons (list graph key) (slot-value 'views))))
  13. (defmeth observation-proto :delete-view (graph)
  14.   (flet ((test (x y) (eq x (first y))))
  15.     (let ((views (slot-value 'views)))
  16.       (if (member graph views :test #'test)
  17.           (setf (slot-value 'views)
  18.                 (delete graph views :test #'test))))))
  19. (defmeth observation-proto :views () (slot-value 'views))
  20. (defmeth observation-proto :change (slot value)
  21.   (setf (slot-value slot) value)
  22.   (dolist (view (send self :views))
  23.     (send (first view) :changed (second view) slot value)))
  24.  
  25. (defproto observation-plot-mixin '(observations variables))
  26. (defmeth observation-plot-mixin :observations ()
  27.   (slot-value 'observations))
  28. (defmeth observation-plot-mixin :variables ()
  29.   (slot-value 'variables))
  30. (defmeth observation-plot-mixin :isnew (vars &rest args)
  31.   (apply #'call-next-method
  32.          (length vars) :variable-labels (mapcar #'string vars) args)
  33.   (setf (slot-value 'variables) vars))
  34. (defmeth observation-plot-mixin :add-observations
  35.       (new-obs &key (draw t))
  36.   (let* ((obs (send self :observations))
  37.          (n (length obs))
  38.          (m (length new-obs))
  39.          (new-obs (coerce new-obs 'vector)))
  40.      (setf (slot-value 'observations)
  41.            (concatenate 'vector obs new-obs))
  42.      (dotimes (i m)
  43.        (send (aref new-obs i) :add-view self (+ i n)))
  44.      (send self :needs-adjusting t)
  45.      (if draw (send self :adjust-screen))))
  46. (defmeth observation-plot-mixin :remove ()
  47.   (call-next-method)
  48.   (let ((obs (send self :observations)))
  49.     (dotimes (i (length obs))
  50.       (send (aref obs i) :delete-view self))))
  51. (defmeth observation-plot-mixin :adjust-screen ()
  52.   (if (send self :needs-adjusting)
  53.       (let ((vars (send self :variables))
  54.             (obs (send self :observations)))
  55.          (send self :clear-points :draw nil)
  56.          (when (< 0 (length obs))
  57.            (flet ((variable (v)
  58.                     (map-elements #'(lambda (x) (send x v)) obs)))
  59.              (send self :add-points (mapcar #'variable vars) :draw nil))
  60.            (dotimes (i (length obs))
  61.              (let ((x (aref obs i)))
  62.                (send self :point-label i (send x :label))
  63.                (send self :point-state i (send x :state))
  64.                (send self :point-color i (send x :color))
  65.                (send self :point-symbol i (send x :symbol)))))
  66.          (send self :needs-adjusting nil)
  67.          (send self :redraw-content))))
  68. (defmeth observation-plot-mixin :changed (key what value)
  69.   (case what
  70.    (state (send self :point-state key value))
  71.    (t (send self :needs-adjusting t))))
  72.  
  73. (defun synchronize-graphs ()
  74.   (dolist (g (active-windows))
  75.    (if (kind-of-p g observation-plot-mixin)
  76.        (send g :adjust-screen))))
  77. (defmeth observation-plot-mixin :erase-selection ()
  78.   (let ((obs (send self :observations)))
  79.     (dolist (i (send self :selection))
  80.       (send (aref obs i) :change 'state 'invisible)))
  81.   (synchronize-graphs))
  82. (defmeth observation-plot-mixin :show-all-points ()
  83.   (let ((obs (send self :observations)))
  84.     (dotimes (i (length obs))
  85.       (send (aref obs i) :change 'state 'normal)))
  86.   (synchronize-graphs))
  87. (defmeth observation-plot-mixin :focus-on-selection ()
  88.   (let* ((obs (send self :observations))
  89.          (showing (send self :points-showing))
  90.          (selection (send self :selection)))
  91.      (dolist (i (set-difference showing selection))
  92.        (send (aref obs i) :change 'state 'invisible)))
  93.   (synchronize-graphs))
  94. (defmeth observation-plot-mixin :menu-template ()
  95.   (remove 'link (call-next-method)))
  96. (defmeth observation-plot-mixin :unselect-all-points ()
  97.   (let ((obs (send self :observations)))
  98.     (dolist (i (send self :selection))
  99.      (send (aref obs i) :change 'state 'normal))
  100.     (send self :adjust-screen)))
  101. (defmeth observation-plot-mixin :adjust-points-in-rect
  102.          (left top width height state)
  103.   (let ((points (send self :points-in-rect left top width height))
  104.         (selection (send self :selection))
  105.         (obs (send self :observations)))
  106.     (case state
  107.       (selected
  108.         (dolist (i (set-difference points selection))
  109.           (send (aref obs i) :change 'state 'selected)))
  110.       (hilited
  111.         (let* ((points (set-difference points selection))
  112.                (hilited (send self :points-hilited))
  113.                (new (set-difference points hilited))
  114.                (old (set-difference hilited points)))
  115.            (dolist (i new) (send (aref obs i) :change 'state 'hilited))
  116.            (dolist (i old) (send (aref obs i) :change 'state 'normal))))))
  117.   (synchronize-graphs))
  118.  
  119. (defproto obs-scatterplot-proto () () (list observation-plot-mixin
  120.                     scatterplot-proto))
  121. (defun plot-observations (obs vars)
  122.   (let ((graph (send obs-scatterplot-proto :new vars)))
  123.     (send graph :new-menu)
  124.     (send graph :add-observations obs)
  125.     (send graph :adjust-to-data)
  126.     graph))
  127.